home *** CD-ROM | disk | FTP | other *** search
/ United Public Domain Gold 2 / United Public Domain Gold 2.iso / utilities / pu659.dms / pu659.adf / Scion / ARexx / Scion2GEDCOM.rexx < prev    next >
OS/2 REXX Batch file  |  1994-05-21  |  13KB  |  453 lines
  1. /****************************************************************************
  2.  *                                                                          *
  3.  * $VER: Scion2GEDCOM 1.11 (1 Mar 1994)
  4.  *                                                                          *
  5.  *                      Written by Freddy Ariës                             *
  6.  *                                                                          *
  7.  * This program was created to export the Scion data into the GEDCOM file   *
  8.  * format. It is still very basic and not user-friendly at all.             *
  9.  *                                                                          *
  10.  * This version uses (by default) the rexxreqtools.library (which requires  *
  11.  * a version of reqtools larger than 2.0 and rexxsyslib.library)            *
  12.  * If you do not have any of these, you need to supply the NOREQ argument,  *
  13.  * except when you supply the QUIET argument.                               *
  14.  *                                                                          *
  15.  * Sexes and dates should be in the English format.                         *
  16.  * Dates should be in the format "DD MMM YYYY", "DD-MMM-YYYY" or            *
  17.  * "DD.MMM.YYYY", if you don't want any problems with programs importing    *
  18.  * the GEDCOM data.                                                         *
  19.  * The database must be running for this AREXX script to work.              *
  20.  *                                                                          *
  21.  * TO DO:                                                                   *
  22.  *  - Parse last names -> Capitalize with rest lowercase                    *
  23.  *  - Better solution for the user-defined PERSONAL and FAMILY fields       *
  24.  *    (PERSUSER1, PERSUSER2, PERSUSER3, FAMUSER1, FAMUSER2)                 *
  25.  *    Current solution: assume defaults                                     *
  26.  *  - Try to enforce the date format "DD MMM YYYY"                          *
  27.  *  - Parsing for ABT, ABOUT, BEF, BEFORE, AFT, AFTER                       *
  28.  *  - If date or place ends with a '?', remove the questionmark and add a   *
  29.  *    QUAY 1 to the data.                                                   *
  30.  *  - Reorganize the database (no holes between individuals or families)    *
  31.  *  - Indicate the use of the 8bit Amiga ASCII character set                *
  32.  *                                                                          *
  33.  ****************************************************************************/
  34.  
  35. options failat 20; options results
  36. arg outname outval
  37.  
  38. versionstr = "1.11"
  39. usereq = 1; /* change this to 0 if you don't want to use reqtools */
  40. outp = 1; output = stdout
  41. NL = '0A'x
  42.  
  43. signal on IOERR
  44.  
  45. /* parse command line options, to enable calling the script automatically,
  46.  * eg. from a function key
  47.  */
  48.  
  49. do while outname = '?'
  50.   writeln(stdout, "OUTFILE/A,QUIET/S,NOREQ/S ")
  51.   pull outname outval
  52. end
  53.  
  54. if outname ~= "" then do
  55.   if outname = "QUIET" | outname = "NOREQ" then do
  56.     outval = outname; outname = ""
  57.   end
  58. end
  59.  
  60. if outval = "QUIET" then do
  61.   outp = 0; usereq = 0
  62. end
  63. else if outval = "NOREQ" then usereq = 0
  64.  
  65. if usereq & ~show('l','rexxreqtools.library') then do
  66.   if exists('libs:rexxreqtools.library') then
  67.     call addlib('rexxreqtools.library',0,-30,0)
  68.   else do
  69.     usereq = 0; outp = 1
  70.     Tell("Unable to open rexxreqtools.library - using text output")
  71.   end
  72. end
  73.  
  74. /* These first few lines are stolen from Peter Billings - thanks Peter ;-) */
  75. if ~show('P','SCIONGEN') then do
  76.   TermError('I am sorry to say that the SCION Genealogist' || NL ||,
  77.     'database is not available. Please start the' || NL ||,
  78.     'SCION program BEFORE using this script!')
  79. end
  80.  
  81. MyPort = "SCIONGEN"
  82. Address value MyPort
  83. GETDBNAME
  84. dbname = upper(RESULT)
  85.  
  86. if outp & ~usereq then do
  87.   Tell("Scion to GEDCOM conversion script v"||versionstr||" by Freddy Ariës")
  88.   Tell("Database: "||dbname|| NL)
  89. end
  90.  
  91. /* It's a good habit to add the ".scion" extension to Scion database files */
  92. dblen = length(dbname)
  93. if dblen>6 & right(dbname, 6)=".SCION" then dbname=left(dbname, dblen - 6)
  94.  
  95. if outname = "" then do
  96.   if outp then do
  97.     if usereq then do
  98.       odev = rtezrequest('Current Scion database: '||dbname||,
  99.        NL||'Where should the GEDCOM output be sent to?'||,
  100.        NL,' _File |_Printer|_Screen|_Nowhere','Scion to GEDCOM v'||versionstr||' by Freddy Ariës')
  101.       select
  102.         when odev = 1 then do
  103.           /* We need a file requester for further data */
  104.           outname = rtfilerequest('RAM:',dbname||'.GED','Output filename')
  105.           if outname = '' then
  106.             outname = dbname||'.GED'
  107.         end
  108.         when odev = 2 then
  109.           outname = 'PRT:'
  110.         when odev = 3 then
  111.           outname = 'STDOUT'
  112.         otherwise
  113.           EXIT
  114.           /* You selected 'Nowhere' */
  115.       end
  116.     end
  117.     else do
  118.       Tell("Enter output file (filename with complete path, or PRT: for printer,")
  119.       TellNN("or STDOUT for screen): ")
  120.       pull outname
  121.       Tell("Destination: "||outname)
  122.       TellNN("Continue (y/n)? ")
  123.       pull conf
  124.       /* Note that left works on empty strings ("") too! */
  125.       if left(conf,1) ~= "Y" then do
  126.         Tell("Goodbye...")
  127.         EXIT
  128.       end
  129.       Tell("")
  130.     end
  131.   end
  132.   else
  133.     outname = "RAM:"dbname".GED"
  134.     /* If we're not allowed to use stdout, default to this filename */
  135. end
  136.  
  137. if outname ~= "STDOUT" then do
  138.   output = 'OUTPUT'
  139.   if ~open(output, outname, "w") then
  140.     TermError("ERROR: Unable to open output file.")
  141. end
  142.  
  143. if ~usereq then
  144.   Tell("Be patient - this may take a while...")
  145.  
  146. GETPROGVERSION
  147. prgvers = RESULT
  148.  
  149. writeln(output, "0 HEAD")
  150. writeln(output, "1 SOUR SCION_AMIGA")
  151. writeln(output, "2 NAME Scion Genealogist")
  152. writeln(output, "2 VERS "||prgvers)
  153. writeln(output, "2 CORP Robbie J. Akins")
  154. writeln(output, "3 ADDR 5 Austin Street, Wellington 6001, New Zealand")
  155.  
  156. str = "1 DATE" upper(date())
  157. writeln(output, str)
  158. writeln(output, "1 @S1@ SUBM")
  159. str = "1 FILE" dbname
  160. writeln(output, str)
  161. writeln(output, "1 GEDC")
  162. writeln(output, "2 VERS 5.2")
  163.  
  164. GETTOTALIRN
  165. TotalIRN = RESULT
  166. do i = 1 to TotalIRN
  167.   EXISTPERSON i
  168.   if RESULT = 'YES' then
  169.   do
  170.     str = "0 @I"i"@ INDI"
  171.     writeln(output, str)
  172.     GETFIRSTNAME i
  173.     fnames = RESULT
  174.     GETLASTNAME i
  175.     lname = RESULT
  176.     str = "1 NAME "fnames"/"lname"/"
  177.     writeln(output, str)
  178.     GETSEX i
  179.     sx = RESULT
  180.     if sx ~= "M" then do
  181.      sx = "F"
  182.     end
  183.     str = "1 SEX" sx
  184.     writeln(output, str)
  185.     GETBIRTHDATE i
  186.     datestr = ParseDate(upper(RESULT))
  187.     GETBIRTHPLACE i
  188.     placestr = RESULT
  189.     if datestr ~= "" | placestr ~= "" then do
  190.       writeln(output, "1 BIRT")
  191.       if datestr ~= "" then do
  192.         str = "2 DATE" datestr
  193.         writeln(output, str)
  194.       end
  195.       if placestr ~= "" then do
  196.         str = "2 PLAC" placestr
  197.         writeln(output, str)
  198.       end
  199.     end
  200.     GETDEATHDATE i
  201.     datestr = ParseDate(RESULT)
  202.     GETDEATHPLACE i
  203.     placestr = RESULT
  204.     if datestr ~= "" | placestr ~= "" then do
  205.       writeln(output, "1 DEAT")
  206.       if datestr ~= "" then do
  207.     str = "2 DATE" datestr
  208.     writeln(output, str)
  209.       end
  210.       if placestr ~= "" then do
  211.     str = "2 PLAC" placestr
  212.     writeln(output, str)
  213.       end
  214.     end
  215.     GETBURIALDATE i
  216.     datestr = ParseDate(RESULT)
  217.     GETBURIALPLACE i
  218.     placestr = RESULT
  219.     if datestr ~= "" | placestr ~= "" then do
  220.       writeln(output, "1 BURI")
  221.       if datestr ~= "" then do
  222.     str = "2 DATE" datestr
  223.     writeln(output, str)
  224.       end
  225.       if placestr ~= "" then do
  226.     str = "2 PLAC" placestr
  227.     writeln(output, str)
  228.       end
  229.     end
  230.     GETPERSUSER1 i
  231.     /* Default: "Occupation" */
  232.     rs1 = RESULT
  233.     if rs1 ~= "" then do
  234.       str = "1 OCCU" rs1
  235.       writeln(output, str)
  236.     end
  237.     GETPERSUSER2 i
  238.     /* "Comments" */
  239.     rs1 = RESULT
  240.     GETPERSUSER3 i
  241.     /* "References" */
  242.     rs2 = RESULT
  243.     if rs1 ~= "" then do
  244.       str = "1 NOTE" rs1
  245.       writeln(output, str)
  246.     end
  247.     else if rs2 ~= "" then do
  248.       /* We need some way to separate the Comments data from the
  249.        * References data - (ab)use the NOTE and CONT fields for that
  250.        */
  251.       str = "1 NOTE -"
  252.       writeln(output, str)
  253.     end
  254.     if rs2 ~= "" then do
  255.       str = "2 CONT" rs2
  256.       writeln(output, str)
  257.     end
  258.     GETPARENTS i
  259.     ParFGRN = RESULT
  260.     EXISTFAMILY ParFGRN
  261.     if RESULT = 'YES' then do
  262.       str = "1 FAMC @F"ParFGRN"@"
  263.       writeln(output, str)
  264.     end
  265.     HuwNum = 0
  266.     GETMARRIAGE i HuwNum
  267.     MarrFGRN = RESULT
  268.     do while MarrFGRN ~= ""
  269.       EXISTFAMILY MarrFGRN
  270.       if RESULT = 'YES' then do
  271.         str = "1 FAMS @F"MarrFGRN"@"
  272.         writeln(output, str)
  273.       end
  274.       HuwNum = HuwNum + 1
  275.       GETMARRIAGE i HuwNum
  276.       MarrFGRN = RESULT
  277.     end
  278.   end
  279. end
  280. if ~usereq then
  281.   Tell("Number of persons output: "||TotalIRN)
  282.  
  283. /* Now the list of families... */
  284.   
  285. GETTOTALFGRN
  286. TotalFGRN = Result
  287. do i = 1 to TotalFGRN
  288.   EXISTFAMILY i
  289.   if RESULT = 'YES' then do
  290.     str = "0 @F"i"@ FAM"
  291.     writeln(output, str)
  292.     GETPRINCIPAL i
  293.     husb = RESULT
  294.     if husb ~= "" then do
  295.       EXISTPERSON husb
  296.       if RESULT = 'YES' then do
  297.     GETSEX husb
  298.     hsx = RESULT
  299.     /* Note: GEDCOM requires 1 husband (male) and 1 wife (female).
  300.      * Scion allows more unconventional matings as well, so we have
  301.      * to improvise a bit here, and hope the receiving program isn't
  302.      * too strict...
  303.      */
  304.     if hsx = "M" then do
  305.       str = "1 HUSB @I"husb"@"
  306.       writeln(output, str)
  307.       GETSPOUSE i
  308.       wife = RESULT
  309.       if wife ~= "" then do
  310.         EXISTPERSON wife
  311.         if RESULT = 'YES' then do
  312.           /* The principal is male; assume the partner is female */
  313.           str = "1 WIFE @I"wife"@"
  314.           writeln(output, str)
  315.         end
  316.       end    
  317.     end
  318.     else do
  319.       /* The principal isn't male - define the partner as male
  320.          and the principal as female
  321.        */
  322.       if hsx ~= "F" then do
  323.             if usereq then
  324.           rtezrequest('WARNING: Unrecognized Sex for Principal'||NL||,
  325.                 'Sex was:'||hsx||'. Assuming FEMALE!','_Continue','Converter Message:')
  326.             else
  327.           Tell("WARNING: Unrecognized Sex for Principal ("||hsx||") - assuming FEMALE")
  328.       end
  329.       GETSPOUSE i
  330.       wife = RESULT
  331.       if wife ~= "" then do
  332.         EXISTPERSON wife
  333.         if RESULT = 'YES' then do
  334.           GETSEX wife
  335.           hsx = RESULT
  336.           if hsx ~= "M" then do
  337.             if usereq then
  338.               rtezrequest('WARNING: No male partner in family!','_Continue','Converter Message:')
  339.                 else
  340.           Tell("WARNING: No male partner in family!")
  341.               end
  342.           str = "1 HUSB @I"wife"@"
  343.           writeln(output, str)
  344.         end
  345.       end
  346.       str = "1 WIFE @I"husb"@"
  347.       writeln(output, str)
  348.     end
  349.       end
  350.     end
  351.     GETMARRYDATE i
  352.     datestr = ParseDate(RESULT)
  353.     GETMARRYPLACE i
  354.     placestr = RESULT
  355.     if datestr ~= "" | placestr ~= "" then do
  356.       writeln(output, "1 MARR")
  357.       if datestr ~= "" then do
  358.         str = "2 DATE" datestr
  359.     writeln(output, str)
  360.       end
  361.       if placestr ~= "" then do
  362.     str = "2 PLAC" placestr
  363.     writeln(output, str)
  364.       end
  365.     end
  366.     GETFAMUSER1 i
  367.     /* "Celebrant" */
  368.     rs1 = RESULT
  369.     GETFAMUSER2 i
  370.     /* "Comments" */
  371.     rs2 = RESULT
  372.     if rs2 ~= "" then do
  373.       str = "1 NOTE" rs2
  374.       writeln(output, str)
  375.     end
  376.     else if rs1 ~= "" then do
  377.       /* We need some way to separate the Celebrant data from the
  378.        * Comments data - (ab)use the NOTE and CONT fields for that
  379.        */
  380.       str = "1 NOTE -"
  381.       writeln(output, str)
  382.     end
  383.     if rs1 ~= "" then do
  384.       str = "2 CONT" rs1
  385.       writeln(output, str)
  386.     end
  387.  
  388.     ChNum = 0
  389.     GETCHILD i ChNum
  390.     ChIRN = RESULT
  391.     do while ChIRN ~= ""
  392.       EXISTPERSON ChIRN
  393.       if RESULT = 'YES' then do
  394.         str = "1 CHIL @I"ChIRN"@"
  395.         writeln(output, str)
  396.       end
  397.       ChNum = ChNum + 1
  398.       GETCHILD i ChNum
  399.       ChIRN = RESULT
  400.     end
  401.     /* optional:
  402.        str = "1 NCHI" ChNum
  403.        writeln(output, str)
  404.      */
  405.   end
  406. end
  407. if usereq then
  408.   rtezrequest('Conversion done.'||NL||'Number of persons output: '||TotalIRN||,
  409.     NL||'Number of families output: '||TotalFGRN||NL,'_Continue','Converter Message:')
  410. else
  411.   Tell("Number of families output: "||TotalFGRN)
  412.  
  413. writeln(output, "0 TRLR")
  414. close('OUTPUT')
  415. EXIT
  416.  
  417. ParseDate: PROCEDURE
  418. parse arg datestr
  419.  
  420. /* optional: remove leading zero's */
  421. /* replace all "-" or "." in the date by " " */
  422. datestr = upper(translate(datestr,'  ','-.'))
  423. return datestr
  424.  
  425. Tell: PROCEDURE EXPOSE outp
  426. parse arg str
  427. if outp then writeln(stdout, str)
  428. return 0
  429.  
  430. TellNN: PROCEDURE EXPOSE outp
  431. parse arg str
  432. if outp then writech(stdout, str)
  433. return 0
  434.  
  435. TermError: PROCEDURE EXPOSE outp output usereq
  436. parse arg str
  437. /* If you turned off stdout, no error messages will be shown! */
  438. if usereq then
  439.   rtezrequest(str,'E_xit','Converter Message:')
  440. else do
  441.   Tell(str || '0A'x)
  442. end
  443. close(output)
  444. EXIT
  445.  
  446. /* Let's make sure you get a nice message when you turn off the printer :-) */
  447.  
  448. IOERR:
  449.   bline = SIGL
  450.   say "I/O error #"||RC||" detected in line "||bline||":"
  451.   say sourceline(bline)
  452.   EXIT
  453.